home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-11 / butt01.zip / UTIL.INC < prev   
Text File  |  1993-01-04  |  7KB  |  231 lines
  1. <<* Util.Inc *>>
  2. <<#pragma
  3.  
  4. <<************************************************************>>
  5. procedure SetIndent( IndentTab : integer )
  6. <<*  set system indent value based on a tab value *>>
  7. begin
  8.   <<* Save old value so it can be restored *>>
  9.   <<* Tab Value = indent space(3) at a time *>>
  10.   set lmargin to lmargin + (IndentTab * 3)
  11. end SetIndent
  12.  
  13. <<************************************************************>>
  14. procedure RestoreIndent( IndentTab : integer )
  15. <<*  Restore previous indent as saved VIA SetIndent *>>
  16. begin
  17.   set lmargin to lmargin - (IndentTab * 3)
  18. end RestoreIndent
  19.  
  20. <<************************************************************>>
  21. function HowMany(Target,Host : string) : integer
  22. <<*  Count the number of occurances of Target in the Host  *>>
  23. integer count
  24. begin
  25. count := 0
  26. while (Target $ Host)
  27.    Host := stuff(Host,1,at(Target,Host),'')
  28.    count := count +1
  29. end
  30. return count
  31. end
  32.  
  33. <<************************************************************>>
  34. function GetUser(CmdPointer : integer ; CmdLine : string) : string
  35. <<* This is a recursive function used to retrieve the n_th entry
  36.    from the user field. Semicolon is the field separator. 16 is the
  37.    maximum CmdPointer value allowed.  *>>
  38. begin
  39. if CmdPointer <= 1
  40.    if at(';',CmdLine) = 1
  41.       return ''   <<* value is null. ie  ;;  *>>
  42.    else
  43.       if at(';',CmdLine) = 0
  44.          return CmdLine  <<* no more separators on the line *>>
  45.       endif
  46.       return left(CmdLine,at(';',CmdLine)-1)
  47.    endif
  48. endif
  49. <<* the next line causes a recursive call *>>
  50. return GetUser(CmdPointer-1,substr(CmdLine,at(';',CmdLine)+1,len(CmdLine)-(at(';',CmdLine)))
  51. end  <<* GetUser *>>
  52.  
  53. <<************************************************************>>
  54. function Seperate(Pointer : integer ; Line,Seperator : string) : string
  55. <<* This is a recursive function used to retrieve the n_th entry
  56.    from the LINE. 'Seperator' is the field separator. 16 is the
  57.    maximum Pointer value allowed.  *>>
  58. begin
  59. if Pointer <= 1
  60.    if at(Seperator,Line) = 1
  61.       return ''   <<* value is null. ie  ;;  *>>
  62.    else
  63.       if at(Seperator,Line) = 0
  64.          return Line  <<* no more separators on the line *>>
  65.       endif
  66.       return left(Line,at(Seperator,Line)-1)
  67.    endif
  68. endif
  69. <<* the next line causes a recursive call *>>
  70. return GetUser(Pointer-1,substr(Line,at(Seperator,Line)+1,len(Line)-(at(Seperator,Line)))
  71. end  <<* Seperate *>>
  72.  
  73. <<************************************************************>>
  74. function AtrCode( atr : integer ) : string
  75. <<* Returns the color attribute in an xBase string form from the 
  76.       attribute code received in 'atr' *>>
  77. string hilite,blink,hues,atrstrg
  78. integer hinib,lonib
  79. begin
  80.   hues := 'N ,BU,G ,BG,R ,BR,GR,W '
  81.   if (atr and 8) = 8
  82.     hilite := '+'
  83.   endif
  84.   if (atr and 128) = 128
  85.     blink := '*'
  86.   endif
  87.   lonib := (atr and 7)
  88.   hinib := ((atr shr 4) and 7)
  89.   atrstrg := rtrim( substr( hues,(lonib * 3) + 1,2 ) ) + blink + hilite + '/'
  90.   atrstrg := atrstrg + rtrim( substr( hues,(hinib * 3) + 1,2 ) )
  91.   RETURN atrstrg
  92. end <<*AtrCode*>>
  93.  
  94. <<************************************************************>>
  95. procedure GenColorAtr
  96. integer lastatr
  97. begin
  98.   if fldsay
  99.     lastatr := forecolor
  100.   else
  101.     lastatr := backcolor
  102.   endif
  103.   if (fldatr <> lastatr)
  104.     gen( 'SET COLOR TO ' )
  105.     if fldget
  106.       gen( ',' )
  107.     endif
  108.     genln( AtrCode(fldatr) )
  109.     if fldsay
  110.       forecolor := fldatr
  111.     else
  112.       backcolor := fldatr
  113.     endif
  114.   endif
  115. end
  116.  <<*GenColorAtr*>>
  117.  
  118. <<************************************************************>>
  119. procedure GenColorHue
  120. <<* Generate a new color setting if the field label color changed *>>
  121. begin
  122.   if (fldhue <> lasthue)
  123.     genln( 'SET COLOR TO ',AtrCode( fldhue ) )
  124.     lasthue := fldhue
  125.   endif
  126. end <<*GenColorHue*>>
  127.  
  128. <<************************************************************>>
  129. procedure WriteLabels
  130. <<* Generate a group of SAYs for field labels and text objects *>>
  131. string box
  132. begin
  133.   forall fldlab
  134.    if not fldnap
  135.     GenColorHue      <<*  Test for color change *>>
  136.     if fldtyp = 'B'  <<*BOX Type*>>
  137.       box := fldlab  <<*Used to swap chars for Character box*>>
  138.       gen( '@ ',fldrow,',',fldcol,',' )
  139.       gen( fldrow+flddec,',',fldcol+fldwid,' BOX "' )
  140.       genln( substr(box,1,3),box[5],box[8],box[7],box[6],box[4],' "' )
  141.     else  <<*All Fields and Text Objects*>>
  142.       genln( '@ ',fldrow,',',fldcol,' SAY "',fldlab,'"' )
  143.     endif
  144.    endif not fldnap
  145.   endfor
  146. end <<*WriteLabels*>>
  147.  
  148. <<************************************************************>>
  149. procedure GenPicture
  150. <<* Generates a picture based on the field type and width 
  151.    or uses the one that the user created  *>>
  152. string picstrg
  153. begin
  154.   if fldpic   <<*  Picture was created by the user  *>>
  155.     gen( ' PICTURE ')
  156.     if 'REPL'$UPPER(fldpic)   <<* REPLICATE() is used as the picture  *>>
  157.       gen(fldpic)
  158.     else   <<*  Picture needs quotation marks  *>>
  159.       picstrg := fldpic
  160.       while '"' $ picstrg   <<*  remove " if found  *>>
  161.          picstrg := stuff(picstrg,at('"',picstrg),1,'')
  162.       endwhile
  163.       while "'" $ picstrg   <<*  remove ' if found  *>>
  164.          picstrg := stuff(picstrg,at("'",picstrg),1,'')
  165.       endwhile
  166.       if LEN(picstrg) < fldwid  <<*  Correct field width *>>
  167.          if '@'$picstrg  <<*  no action when it is a function *>>
  168.          else
  169.             picstrg := replicate( LEFT(picstrg,1),fldwid )
  170.          endif
  171.       endif
  172.       gen( '"',picstrg,'"' )
  173.     endif
  174.   else   <<*  No picture by user  **>>
  175.     if fldtyp = 'N'  <<* No picture so Force numeric picture *>>
  176.        picstrg := replicate( '9',fldwid )
  177.        if flddec
  178.          picstrg[ fldwid-flddec ] := '.'
  179.        endif
  180.        gen( ' PICTURE "',picstrg,'"' )
  181.     elsif fldtyp = 'C'  <<* No picture so Force character picture *>>
  182.       if fldwid > 29
  183.        picstrg := replicate( 'X',fldwid )
  184.        gen( ' PICTURE REPLICATE("X",',STR(fldwid),')' )
  185.       else
  186.        picstrg := replicate( 'X',fldwid )
  187.        gen( ' PICTURE "',picstrg,'"' )
  188.       endif
  189.    endif
  190.   endif
  191. end <<*GenPicture*>>
  192.  
  193. <<************************************************************>>
  194. procedure GenFldList( cmdword : string )
  195. <<* Generate a list of variables in groups of 3 lines, 7 per line *>>
  196. integer linecount,linemax,fldtally,memtotal
  197. logical isnewln
  198. begin
  199.   linemax := 2     <<*  Max Lines -1  *>>
  200.   fldtally := 0
  201.   linecount := 9
  202.   isnewln := true
  203.   forall  fldtyp $ 'CDLN'
  204.     if (UPPER(LEFT(GetUser(1,fldusr),4)) <>'MULT') and not fldnap
  205.        if isnewln
  206.          linecount := linecount + 1
  207.          if linecount > linemax 
  208.           if linecount < 10
  209.             genln    <<* not on first pass *>>
  210.           endif
  211.            genln( cmdword )
  212.            linecount := 0
  213.          else
  214.            genln( ',;' )
  215.          endif
  216.          gen( space(3) )   <<*indent=3*>>
  217.        else
  218.          gen( ',' )
  219.        endif
  220.        fldtally := fldtally + 1
  221.        isnewln := (fldtally mod 7 = 0)  <<*  7 vars per line *>>
  222.        gen( 'm',fldnam )
  223.     endif not fldnap
  224.   endfor
  225.   genln  <<*CR/LF*>>
  226. end <<*GenFldList*>>
  227.  
  228. #>>
  229. <<*  EOF: Util.Inc  *>>
  230.  
  231.